;; -*- Mode: Lisp; -*-

;;;; Database for Fast Tiny Rule Engine
;;;;  Modified: forbus on Tue Apr 2 10:18:02 1996

;;; Copyright (c) 1988-1991, Kenneth D. Forbus, Northwestern University,
;;; and Johan de Kleer, the Xerox Corporation.
;;; All rights reserved.

;;; See the file legal.txt for a paragraph stating scope of permission
;;; and disclaimer of warranty.  The above copyright notice and that
;;; paragraph must be included in any separate copy of this file.

(defpackage #:bps/ftre/fdata
  (:use #:cl #:bps/ftre/unify #:bps/ftre/finter)
  (:export
   #:dbclass
   #:dbclass-p
   #:make-dbclass
   #:dbclass-name
   #:dbclass-ftre
   #:dbclass-facts
   #:dbclass-rules
   #:show-data
   #:assert!
   #:rassert!
   #:insert
   #:get-dbclass
   #:fetch
   #:get-candidates
   #:map-dbclass
   #:try-rules
   #:quotize))

(in-package #:bps/ftre/fdata)

;; An assertion is just the lisp form itself.
;; The "dbclass" of an assertion is the leftmost constant
;; symbol in the form.  Dbclasses are used to store rules
;; and data.

(defstruct (dbclass (:PRINT-FUNCTION print-dbclass-struct))
     name               ;a symbol
     ftre               ;ftre it belongs to
     facts              ;facts of this dbclass
     rules)             ;rules applicable to this dbclass

(defun print-dbclass-struct (cl st ignore)
  (declare (ignore ignore))
  (format st "<Dbclass ~D>" (dbclass-name cl)))

(defun show-data (&optional (stream *standard-output*)
                            &aux counter)
  (setq counter 0)
  (format stream "~%In global context: ")
  (maphash #'(lambda (key dbclass)
               (declare (ignore key))
               (dolist (datum (dbclass-facts dbclass))
                       (incf counter)
                       (format stream "~%~A" datum)))
           (ftre-dbclass-table *ftre*))
  (format stream "~%  ~D assertions in global context."
          counter)
  (when (> (ftre-depth *ftre*) 0)
        (format stream "~% In current context:")
        (dolist (datum (reverse (ftre-local-data *ftre*)))
                (unless (numberp datum) (incf counter))
                (format stream "~% ~A." datum)))
  counter)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Inserting data

(defun assert! (fact &optional (*ftre* *ftre*))
  (when (insert fact *ftre*) (try-rules fact *ftre*)))

(defmacro rassert! (fact) `(assert! ,(quotize fact)))

(defun insert (fact ftre &aux dbclass)
  (when (null fact) (error "~% Can't assert NIL."))
  (setq dbclass (get-dbclass fact ftre))
  (cond ((member fact (dbclass-facts dbclass)
                 :TEST #'equal) nil)
        ((= (ftre-depth ftre) 0)
         (push fact (dbclass-facts dbclass)))
        ((member fact (ftre-local-data ftre)
                 :TEST #'equal) nil)
        (t (push fact (ftre-local-data *ftre*)))))

(defun get-dbclass (fact ftre &aux dbclass)
  (cond ((null fact) (error "~% NIL can't be a dbclass."))
        ((listp fact) (get-dbclass (car fact) ftre))
        ((variable? fact) ;; *ENV* is no longer used.
         (cond ((boundp fact)
                (get-dbclass (symbol-value fact) ftre))
               (t (error "~%Dbclass unbound: ~A" fact))))
        ((symbolp fact)
         (cond ((gethash fact (ftre-dbclass-table ftre)))
               (t (setq dbclass
                        (make-dbclass :NAME fact :FTRE ftre
                                    :FACTS nil :RULES nil))
                  (setf (gethash
                         fact (ftre-dbclass-table ftre))
                        dbclass)
                  dbclass)))
        (t (error "Bad dbclass type: ~A" fact))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Retrieving data

(defun fetch (pattern &optional (*ftre* *ftre*)
                      &aux bindings unifiers)
  (dolist (candidate (get-candidates pattern *ftre*)
                     unifiers)
    (setq bindings (unify pattern candidate))
    (unless (eq bindings :FAIL)
      (push (sublis bindings pattern) unifiers))))

(defun get-candidates (pattern ftre)
  (append (ftre-local-data ftre)
          (dbclass-facts (get-dbclass pattern ftre))))

(defun map-dbclass (proc &optional (*FTRE* *FTRE*))
  (maphash #'(lambda (name dbclass) (declare (ignore name))
               (funcall proc dbclass))
           (ftre-dbclass-table *FTRE*)))
